perm filename T3.F4[M11,LCS]4 blob
sn#409390 filedate 1979-01-13 generic text, type T, neo UTF8
00100 SUBROUTINE MSCAN
00200 CXX DOUBLE PRECISION JFLNM,INST,INAM
00300 DIMENSION TONES(21)
00400 COMMON LL /P/W(1)
00500 CIN COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,4),K
00600 CC COMMON /I/I(1) /TR/RX(80),JX(80),LX(12),K
00700 COMMON /ROUT/I(200),RX(80),JX(80) /TR/LX(12),K
00800 1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
00900 1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
01000 1,ENDX,J /KNAM/IPLAY,JFLNM
01100 1 /INST/INST(1)
01200 COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT
01300 INTEGER RPR
01400 EQUIVALENCE (LESS,LX(9)),(W1,W(1)),(W2,W(2)),(W3,W(3)),(W4,W(4)),
01500 1 (RX2,RX(3)),(P2,P(2)),(RX3,RX(5)),(I3,I(3))
01600 1 ,(ISEMI,LX(2)),(IAST,LX(3))
01700 1,(LPR,LX(11)),(RPR,LX(12)),(ICOM,LX(10)),(LAROW,LX(7))
01800 DATA TONES/246.945,261.62,277.18,277.8,293.66,311.13,311.13,
01900 1 329.63,349.23,329.63,349.23,369.99,369.99,
02000 1 391.99,415.31,415.31,440.0,466.16,466.16,493.89,523.24/
02100
02200 C**** CODE NUMS. 1=OUT 2=OSC 3=AD2 4=RAN 5=END 6=STR 7=AD3 8=AD4 9=MLT
02300 C**** 10=DIV 11=RAH 12=END 13=REV 14=OPT 15=NOS 16=SUB 17=INP 18=COS
02400 C**** B1=101 ETC. P1=201 ETC. F1=301 ETC. FREQ-PARAMS=600S, DURS=700S.
02500 C**** 400=PLAY 401=FINI 402=SRATE 403=NCHNS 404=PRINT 405=CHA
02600 C**** 407=SRT 409=GEN 410=SEG 411=SIN 412=INS 413=UNIT GEN.
02700 C**** 500=CF 501=C 502=CS 503=DF 504=D 505=DS 506=EF 507=E 508=ES 509=FF
02800 C**** 510=F 511=FS 512=GF 513=G 514=GS 515=AF 516=A 517=AS 518=BF 519=B 520=BS
02900
03100 JSEM=0
03200 C IS THIS NEEDED HERE?
03300 C JSEM=0 FOR 'PLAY' OR ASSIGNMENT ( P3←440;, A=444; ETC.)
03400 LL=1
03500 INS=-1
03600 34 J=J+2
03700 2324 FORMAT(1X20F10.3/)
03800 2325 FORMAT(1X20I/)
03900 2323 FORMAT(1X20A1/)
04000 IXJ=JX(J)
04100 IPP=0
04200 C!FOR 'P3←333;' ETC.
04300 IOP=-1
05000 9 IF(J.GE.MM)GO TO 1001
05100 IF(RX(J+1).EQ.-9999.0)GO TO 11
05200 C!*** SKIP IF NUMBER
05300 IF(IGEN.GT.0)GO TO 450
05400 C IGEN=2=INSIDE AN INST. DEFINITION.
05500
05600 C!***** LOOK FOR SPECIAL WORDS
05700 IF(IXJ/400.NE.1)GO TO 402
05800 K=IXJ-399
05900 C PRINT
06000 GO TO (13,13,304,303,302,303,4,505,505,422,422,422,32)K
06100 C (PLAY) FINI SRAT NCHN CHA SRT GEN SEG SIN INS
06200 32 W1=2
06300 IXJ=13
06400 JX(J)=13
06500 IGEN=2
06600 GO TO 424
06700 505 JK=4
06800 C !**** FOR SRT
06900 IF(K.NE.4)JK=2
07000 JK=J+JK
07100 GO TO 304
07200
07300 450 K=IXJ
07400 C** HERE FOR INST DEFINITIONS.
07500 CC IF(K.LE.13.AND.K.GT.0)GO TO(425,425,425,425,425
07600 CC 1,425,425,425,425,425,425,411),K
07700 CC IF(K.EQ.14)GO TO 425
07800 C 14='OPT' USER-ADDED UNIT GENERATOR.
07900 IF(K.EQ.12)GO TO 412
08000 IF(K.GT.0)GO TO 425
08800 CC503 JSEM=0
08900 CC J=MM
09000 CC RETURN
09050 GO TO 1001
09100 504 FORMAT(' UNKNOWN SYMBOL ',A4)
09200 412 LL=3
09300 IGEN=1
09400 C!*** =1 IS FLAG TO CHANGE IT TO -1
09500 J=MM
09600 INS=-1
09700 GO TO 10
09800 422 W1=3
09900 C!***** GEN
10000 IF(K.GT.10)W1=K-4
10100 C SEG=11, SIN=12 AT THIS POINT.
10200 IGEN=0
10300 424 INS=-1
10400 LL=2
10500 GO TO 36
10600 425 W3=K+100
10700 436 LL=4
10800 GO TO 36
10900
11000 CC3 J=J+2
11100 C 'PLAY' IS NO LONGER NEEDED.
11200 C !**** FOUND 'PLAY;'
11300 CC IF(JX(J).NE.ISEMI)CALL ERR(1)
11400 C FLAG FOR 'TRANS'
11500 CXXX IPLAY=-1
11700 CC IF(J.LT.MM)GO TO 34
11900 CC PAUSE 'BEFORE LABEL 4'
12000 CC RETURN
12100 4 JL=LL
12200 JOP=IOP
12300 J=J+2
12400 IF(JX(J).NE.LPR)CALL ERR(2)
12500 IOP=-1
12600 GO TO 36
12700 C!**FIND NUM UP TO THE COMMA
12800 302 LL=1
12900 IPRNT=-1
13000 C!***** FOR 'PRINT' FEATURE
13100 GO TO 36
13200 304 SRATE=RX(J+4)
13300 J=J+6
13400 RMAG=512./SRATE
13500 W3=4
13600 W4=SRATE
13700 351 W1=11
13800 W2=0
13900 IGEN=0
14000 LL=5
14050 C JSEM=-1 = SEND DATA BACK TO MUS5,PASS3.
14100 10 JSEM=-1
14200 RETURN
14300 CCC303 IF(IXJ.EQ.405)J=J-2
14400 303 RNCHN=RX(J+4)
14500 C!**** FOR NCHNS←N; OR CHA ← N;
14600 J=J+6
14700 CC IF(RX(JK+1).NE.-9999.0)JK=JK+2
14800 C!*** SKIP A COMMA
14900 CC IF(JX(JK+2).EQ.ISEMI)GO TO 352
15000 C!*** FOR NCHNS←n;
15100 352 W3=8
15200 C!*** FOR NCHNS
15300 W4=RNCHN-1
15400 GO TO 351
16000 36 J=J+2
16100 IF(J.GT.MM)GO TO 1001
16200 C!****** 50 = DONE
16300 CC JK=J*2
16400 CCC IXJ=JX(J)
16500 CX TYPE 2324,RX(J+1)
16600 CX TYPE 2323,IXJ
16700 CX TYPE 2325,IXJ,IOP,IGEN
16800 CX PAUSE 'LABEL 36'
16900 IF(IPLAY.LT.0)P(LL-3)=W(LL-1)
17100 C **** LL HAD BETTER ALWAYS BE >3 HERE.
17200 C FILL UP PARAM LIST WITH DATA FOLLOWING INST NAME.
17300 1002 IXJ=JX(J)
17350 IF(IXJ.NE.ISEMI)GO TO 1
17500 IPLAY=0
17600 1000 IF(IPP.EQ.0)GO TO 10
17700 P(IPP)=W1
17800 LL=1
17900 IPP=0
18000 IF(J.LT.MM)GO TO 34
18100 CC IF(J.LT.MM)GO TO 30
18200 INS=-1
18300 C!*** I HOPE THIS IS THE RIGHT PLACE FOR THIS.
18600 CX PAUSE 'LABEL 1001'
18700 1001 JSEM=0
18800 RETURN
18900
19000 1 IF(RX(J+1).NE.-9999.0)GO TO 2
19100 CX TYPE 2325,IOP
19200 CX PAUSE 'LABEL 1'
19300 11 IF(IOP.LT.0)GO TO 40
19400 IF(IOP.NE.6)GO TO 12
19500 RX(J)=-RX(J)
19600 C!*** IOP=6 MEANS MINUS WITH COMMA IN FRONT
19700 W(LL)=RX(J)
19800 LL=LL+1
19900 GO TO 14
20000 12 CALL ARITH(RX(J),W,LL)
20100 14 IOP=-1
20200 C!*** RESET OPERATOR FLAG
20300 GO TO 36
20400 C!*** USE PARENTH'S FOR COMPOSITE EXPRESSIONS!!!!
20500
20600 40 W(LL)=RX(J)
20700 38 LL=LL+1
20800 IF(IOP.LT.0)GO TO 36
20900 C IOP = NEG = NO OPERATOR BEFORE THIS ITEM.
21000 LL=LL-1
21100 380 CALL ARITH(W(LL),W,LL)
21200 GO TO 14
21300
21500 C!**** READING CONTINUATION LINE.
21600 402 IF(IXJ.GE.0)GO TO 33
21700 C NEXT TRIES TO FIND INST. NAME.
21800 CIN NA=-1-IXJ
21900 CIN M=JX(J+1)
22000 C NA POINTS TO SPOT IN I ARRAY, M IS WDCNT.
22100 CALL PACKER(INAM,I(-IXJ))
22200 DO 233 IK=1,INUM
22300 233 IF(INST(IK).EQ.INAM)GO TO 333
22400 TYPE 504,INAM
22500 GO TO 33
22600 CIN DO 133 IK=1,INUM
22700 CIN DO 233 II=1,M
22800 CIN233 IF(INST(IK,II).NE.I(II+NA))GO TO 133
22900 C NOW WE FOUND AN INST. NAME.
23000 C******* INST NAMES CANNOT HAVE SAME STRING OF 1ST LETTERS AS OTHER THINGS.
23100 333 IPLAY=-1
23200 C FLAG TO START FILLING PARAMS.
23310 W2=INSNUM(IK)
23320 C!**** W IS P ARRAY IN MUSIC5
23330 LL=3
23340 C!**** W2 AND W3 WILL BE EXCHANGED LATER
23360 J=J+2
23380 GO TO 1002
23400 CC333 IF(M.EQ.4)GO TO 35
23500 CC M=M+1
23600 CC IF(INST(IK,M).EQ.0)GO TO 333
23700 CIN133 CONTINUE
23800 33 INS=2
23900 C! NEXT IS SOMETHING OUTSIDE OF INST. AND PARAMS.
24000
24100 2 IF(IGEN.GT.0)GO TO 427
24200 IF(IXJ.GT.520)GO TO 341
24300 IF(IXJ.LT.500)GO TO 427
24400 C NOW FOUND A NOTE
24500 K=IXJ-499
24600 W(LL)=TONES(K)
24700 GO TO 38
24800 C!***** FINDS NOTE IN SCALE
24900
25000 C!****** FIND A PARAM NUM.
25100 427 IF(IXJ.GE.300)GO TO 307
25200 IF(IXJ.LT.200)GO TO 344
25300 K=IXJ-200
25400 C NOW K HAS PARAM NUM.
25500 IF(INS.LE.0)GO TO 340
25600 JK=J+2
25700 IF(JX(JK).NE.LAROW)GO TO 340
25800 IPP=K
25900 LL=1
26000 J=JK
26100 GO TO 36
26200 340 W(LL)=P(K)
26300 C!***** FOUND Pn
26400 IF(IPRNT.LT.0)GO TO 38
26500 IF(IGEN.GT.0)W(LL)=K+2.
26600 C!*** PARAM NUMS ARE 2 LESS THAN IN BOOK.
26700 GO TO 38
26800 C!**** P4 IS CHANGED TO 6
26900 307 IF(IXJ.GE.400)GO TO 344
27000
27100 IF(IXJ/300.NE.1)GO TO 344
27200 JL=IXJ-300
27300 IF(IGEN.GT.0)JL=-JL-100
27400 C!*** FOR Fn IN INST DEFINITION
27500 W(LL)=JL
27600 GO TO 38
27700
27800 344 IF(IGEN.LE.0)GO TO 341
27900 C*** FOR B1, ETC. IN INST. DEFS.
28000 IF(IXJ/100.NE.1)GO TO 341
28100 W(LL)=100-IXJ
28200 GO TO 38
28300
28400 341 DO 39 K=3,6
28500 IF(LX(K).NE.IXJ)GO TO 39
28600 IF(K.NE.3)GO TO 342
28700 IF(JX(J+2).NE.IAST)GO TO 342
28800 C NOW FOUND 'X**Y', =X TO THE POWER OF Y
28900 K=7
29000 J=J+2
29100 342 IOP=K-2
29200 C IOP NUMS ARE: 1=+ 2=- 3=* 4=/ 5=**
29300 JK=JX(J-2)
29400 IF(JK.EQ.ICOM)IOP=6
29500 C!** COMMA DISABLES NEXT OPERATOR
29600 IF(JK.EQ.LAROW)IOP=6
29700 C!** ← DISABLES NEXT OPERATOR
29800 IF(JK.EQ.LPR)IOP=6
29900 C!** LFT PARENTH. DISABLES NEXT OPERATOR
30000 GO TO 36
30100 39 CONTINUE
30200 308 IF(IXJ.EQ.LAROW)GO TO 36
30300 C!*** PASS LEFT ARROW
30400 IF(IXJ.EQ.RPR)GO TO 500
30500 IF(IXJ.EQ.LPR)GO TO 500
30600 C LEFT AND RIGHT PARENTHESES
30700 IF(IXJ.NE.402)GO TO 510
30800 C 402=SRATE
30900 W(LL)=SRATE
31000 335 LL=LL+1
31100 GO TO 36
31200 C**** OR SHOULD NEXT BE 403???
31300 510 IF(IXJ.NE.403)GO TO 511
31400 C 403-'NCHNS'
31500 W(LL)=RNCHN
31600 GO TO 335
31700 511 IF(IXJ.NE.ICOM)RETURN
31710 CC511 IF(IXJ.NE.ICOM)GO TO 503
31800 C!***** UNKNOWN CHAR.
31900 500 IF(IXJ.NE.LPR)GO TO 501
32000 KOP=IOP
32100 IOP=-1
32200 JL=LL
32300 C!**** SAVE VARIOUS POINTERS WHEN INSIDE PARENTHS.
32400 GO TO 36
32500 501 IF(IXJ.NE.RPR)GO TO 502
32600 C!*** GET BACK STUFF
32700 IOP=KOP
32800 IF(IOP.LT.0)GO TO 36
32900 LL=JL
33000 GO TO 380
33100 C!GO DO ARITHMETIC
33200 502 IF(IPRNT)GO TO 36
33300 C!**** FOUND COMMA IN PRINT STATEMENT.
33400 5 IF(JX(J-2).NE.ICOM)GO TO 132
33500 433 W(LL)=P(LL-2)
33600 C!** ONLY CARES ABOUT 2 COMMAS IN A ROW
33700 GO TO 335
33800 132 IF(INS.GE.0)GO TO 36
33900 IF(LL.EQ.3)GO TO 433
34000 C!*** =3 MEANS COMMA FOR P1.
34100 GO TO 36
34200
34300 13 LL=2
34600 W1=6
34700 CC W2=ENDX+.5
34800 W2=ENDX
34900 C!***** ENDX IS P1+P2 OF THE LONGEST LASTING INST.
35000 IF(JPRNT)TYPE 51,LL,W1,W2
35100 130 J=MM
35300 C!*** WON'T READ LINE BEYOND 'FINISH;' ***************
35400 ENDX=-1
35500 51 FORMAT(I3,35F10.3)
35600 END
35700